Methods

library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)

df <- read.csv("data/data.csv") |>
  mutate(
    Date = lubridate::dmy(Date),
    Participant = fct_reorder(Participant, Date),
    Screen_Refresh = as.character(Screen_Refresh),
    Education = fct_relevel(Education, "Doctorate", "Master", "Bachelor", "High School", "Other", "Prefer not to Say"),
    Belief = fct_relevel(Belief, "Fake", "Real"),
    Stimulus_Interest = case_when(
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Opposite" ~ TRUE,
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Same" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Opposite" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Same" ~ TRUE,
      Sexual_Orientation %in% c("Bisexual", "Queer", "Pansexual") ~ TRUE,
      TRUE ~ NA
    )
  )


# head(df[is.na(df$Stimulus_Attract), ])

# Create individual scores for Simulation Monitoring
df <- df |>
  group_by(Participant, Belief) |>
  summarise(
    Confidence = mean(abs(Belief_Confidence)),
    n = n() / 109
  ) |>
  pivot_wider(names_from = "Belief", values_from = c("Confidence", "n")) |>
  ungroup() |>
  merge(df, by = "Participant")

Exclusions

outliers <- c(
  # More than 2 attention check fails
  "611d03b822d4c8e041ea0c32_m0knb",
  "5f0f0a2a8b2a480447f31b21_lqgpz",
  # Very short duration for questionnaire + low rating correlations (< 0.1)
  "5eaef8702b68455d6e130595_ptsga",
  "61356174c090b0083f131e01_asm81",
  # Prefered not answering to sexual orientation: further analysis impossible
  "60eb34f117838a34a29a69d3_rxv85"
)
outliers_partial <- c(
  # 1 attention check failed
  "5dc3485219ca0326027ce91f_37ho9",
  "5c6414540821d30001046198_x9q7r",
  "60dd7b03f1e72d38230df476_9yh9n",
  "5962799cb752840001ca478b_jh4sl",
  "5f44c23fbf2ddb80bcdf0edc_dnbny",
  "5e80370d48b5f47170e30e5c_5w2gf"
)

We removed 5 participants based on failed attention checks.

Extreme Items

extreme_items <- df |>
  group_by(Stimulus, Belief) |>
  summarize(n = n() / length(unique(df$Participant))) |>
  pivot_wider(values_from = "n", names_from = "Belief") |>
  mutate(File = paste0("experiment/stimuli/AMFD/", Stimulus)) |>
  arrange(Real) |>
  filter(Real < 0.15 | Real > 0.85)


p_item <- df |>
  filter(Stimulus %in% extreme_items$Stimulus) |>
  mutate(Stimulus = fct_relevel(Stimulus, as.character(extreme_items$Stimulus))) |>
  ggplot(aes(x = Belief_Answer, y = Stimulus, fill = Stimulus)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups") +
  geom_vline(xintercept = 0, linetype = "dotted") +
  ggimage::geom_image(data = extreme_items, aes(image = File, x = 0, y = Stimulus), size = 0.1, by = "height") +
  # scale_y_discrete(expand = c(0.5, 0.5)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-1, 0, 1),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d(option = "inferno") +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    # axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )
# p_item


df <- df |>
  filter(!Stimulus %in% extreme_items$Stimulus)

extreme_items
## # A tibble: 1 × 4
## # Groups:   Stimulus [1]
##   Stimulus     Fake  Real File                               
##   <chr>       <dbl> <dbl> <chr>                              
## 1 NF-1071.jpg 0.887 0.113 experiment/stimuli/AMFD/NF-1071.jpg

We removed 1 trials per participant.

Attention Checks and Duration

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, starts_with("Attention"), starts_with("Duration"), n_Fake) |>
  slice(1) |>
  ungroup() |>
  rowwise() |>
  mutate(Attention_Check = mean(c(Attention_Check1, Attention_Check2, Attention_Check3))) |>
  ungroup() |>
  arrange(Attention_Check)

Ratings

dfsub$r_Trustworthy <- NA
dfsub$r_Attractive <- NA
dfsub$r_Beauty <- NA
for (participant in dfsub$Participant) {
  dfsub[dfsub$Participant == participant, "r_Trustworthy"] <- cor(df[df$Participant == participant, "Trustworthy"], df[df$Participant == participant, "Norms_Trustworthy"])
  dfsub[dfsub$Participant == participant, "r_Attractive"] <- cor(df[df$Participant == participant, "Attractive"], df[df$Participant == participant, "Norms_Attractive"])
  dfsub[dfsub$Participant == participant, "r_Beauty"] <- cor(df[df$Participant == participant, "Beauty"], df[df$Participant == participant, "Norms_Attractive"])
}

Summary

data.frame(Participant = c(paste0("Total (n=", nrow(dfsub), ")")), t(sapply(dfsub[2:ncol(dfsub)], mean, na.rm = TRUE))) |>
  rbind(dfsub) |>
  mutate(Attention_Check = paste0(
    insight::format_value(Attention_Check, 1),
    " (", insight::format_value(Attention_Check1, 1),
    ", ",
    insight::format_value(Attention_Check2, 1),
    ", ",
    insight::format_value(Attention_Check3, 1),
    ")"
  )) |>
  select(-Attention_Check1, -Attention_Check2, -Attention_Check3) |>
  datawizard::data_relocate("Attention_Check", 2) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE) |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers) + 1, background = "#EF9A9A") |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers_partial) + 1, background = "#FFCC80")  |> 
  kableExtra::kable_styling(full_width = TRUE) |> 
  kableExtra::scroll_box(width = "100%", height = "500px")
Participant Attention_Check Duration_Questionnaires Duration_Task n_Fake r_Trustworthy r_Attractive r_Beauty
Total (n=150) 1.0 (1.0, 1.0, 1.0) 12.18 23.8 0.442 0.273 0.435 0.457
611d03b822d4c8e041ea0c32_m0knb 0.6 (0.6, 0.4, 0.6) 6.00 20.5 0.248 0.164 0.208 0.225
5f0f0a2a8b2a480447f31b21_lqgpz 0.6 (0.2, 1.0, 0.5) 164.70 17.6 0.642 -0.144 0.343 0.288
5962799cb752840001ca478b_jh4sl 0.7 (1.0, 0.2, 1.0) 19.93 30.4 0.284 0.063 0.344 0.326
5dc3485219ca0326027ce91f_37ho9 0.8 (0.5, 1.0, 1.0) 7.01 16.1 0.587 0.253 0.572 0.557
5c6414540821d30001046198_x9q7r 0.9 (1.0, 1.0, 0.6) 9.84 23.4 0.284 0.330 0.483 0.466
60dd7b03f1e72d38230df476_9yh9n 0.9 (0.6, 1.0, 1.0) 12.86 19.9 0.092 0.435 0.429 0.550
5f44c23fbf2ddb80bcdf0edc_dnbny 0.9 (0.7, 1.0, 1.0) 4.71 24.8 0.486 0.103 0.147 0.195
5e80370d48b5f47170e30e5c_5w2gf 0.9 (0.7, 1.0, 1.0) 5.64 22.8 0.440 0.350 0.604 0.612
61356174c090b0083f131e01_asm81 0.9 (0.8, 1.0, 1.0) 9.64 17.5 0.349 0.055 0.081 0.086
60920010e7bfd828a698e5dd_0elu0 0.9 (0.8, 1.0, 1.0) 17.48 27.2 0.404 0.198 0.446 0.480
608ee67f23c2f9f721ddf2a0_bk1h0 1.0 (0.9, 1.0, 1.0) 18.95 19.4 0.477 0.356 0.481 0.448
5fb7cfde7808523cea8ee891_xlrlw 1.0 (0.9, 1.0, 1.0) 6.95 17.7 0.514 0.324 0.515 0.532
613aa96038862e4f29605ade_as7q6 1.0 (0.9, 1.0, 1.0) 14.12 21.6 0.532 0.483 0.287 0.312
613e4bf960ca68f8de00e5e7_cfsdt 1.0 (0.9, 1.0, 1.0) 11.15 23.8 0.468 0.265 0.466 0.428
6115d9fa61078b29b8db91ff_ewn8c 1.0 (0.9, 1.0, 1.0) 11.06 19.3 0.440 0.452 0.250 0.341
5f1acd8cb55680224c3d452a_56nun 1.0 (0.9, 1.0, 1.0) 11.66 26.0 0.642 0.383 0.527 0.518
62fbf0a70bb3960cd2e5fbc9_2xhgq 1.0 (0.9, 1.0, 1.0) 10.01 21.5 0.505 0.492 0.539 0.653
5b8646582c180900019c9eb7_xt3l6 1.0 (1.0, 1.0, 1.0) 20.16 21.4 0.514 0.308 0.363 0.338
5d936374253d0a0017f32d96_n98qu 1.0 (1.0, 1.0, 1.0) 6.87 13.3 0.440 0.233 0.455 0.457
6075d10e3819fae797f0e3d6_s7lm6 1.0 (1.0, 1.0, 1.0) 12.33 22.9 0.560 0.157 0.264 0.357
611b86fe4bd6db6f42e4afea_4asue 1.0 (1.0, 1.0, 1.0) 17.36 36.8 0.330 0.421 0.279 0.365
613cebea47d2d13a9db63d44_4fbms 1.0 (1.0, 1.0, 1.0) 8.51 26.8 0.468 0.330 0.440 0.628
5f233d7f53212b0e22bf055d_x9368 1.0 (1.0, 1.0, 1.0) 13.32 16.7 0.624 0.430 0.603 0.619
5fb015142942a535524f55fc_u1vq2 1.0 (1.0, 1.0, 1.0) 14.47 18.4 0.624 0.428 0.575 0.598
5d7f8ffae664ab001967d9d3_7mrcg 1.0 (1.0, 1.0, 1.0) 4.83 11.5 0.468 0.306 0.209 0.361
613a92a2dbedc6e7aad89199_thehb 1.0 (1.0, 1.0, 1.0) 10.85 40.0 0.541 0.305 0.462 0.456
5ad63c167f70c10001904bc5_ers7p 1.0 (1.0, 1.0, 1.0) 12.18 25.6 0.413 0.298 0.466 0.521
5bb511c6689fc5000149c703_d9k0p 1.0 (1.0, 1.0, 1.0) 12.56 21.8 0.083 0.405 -0.168 0.351
5d40a12f4994c40001e4b80c_2ytoa 1.0 (1.0, 1.0, 1.0) 13.25 21.8 0.587 0.338 0.609 0.521
5eaef8702b68455d6e130595_ptsga 1.0 (1.0, 1.0, 1.0) 2.69 14.9 0.523 0.021 0.091 0.096
5eb17f5f5b4ec12749a65a24_cmop5 1.0 (1.0, 1.0, 1.0) 11.40 18.9 0.450 0.358 0.362 0.514
5ed8e10d54fe053fbc756c72_zknp4 1.0 (1.0, 1.0, 1.0) 7.63 26.3 0.468 -0.056 0.540 0.444
5f034ecf38c5aa527d056830_2pvm9 1.0 (1.0, 1.0, 1.0) 10.09 19.0 0.339 0.274 0.564 0.539
5f3801b18c88962be7831304_ubcua 1.0 (1.0, 1.0, 1.0) 8.73 16.8 0.330 0.153 0.578 0.558
5faa6cab8ac7a937a5240fcb_xsbot 1.0 (1.0, 1.0, 1.0) 10.20 14.9 0.505 0.153 0.544 0.517
601941db6605160008690742_twd28 1.0 (1.0, 1.0, 1.0) 6.25 13.9 0.578 0.299 0.453 0.444
6036ab8b13ac9c79d7e67e81_ln8ep 1.0 (1.0, 1.0, 1.0) 7.14 13.4 0.651 0.273 0.265 0.312
60a256f83ef6ada5debc47a9_q7wl4 1.0 (1.0, 1.0, 1.0) 6.03 16.0 0.321 0.218 0.520 0.451
60a3a03bc01ba594c9cca88d_v0jdv 1.0 (1.0, 1.0, 1.0) 11.76 30.0 0.495 0.406 0.258 0.410
60b6c415dbda3236ea22455a_dmezs 1.0 (1.0, 1.0, 1.0) 24.73 43.0 0.450 0.263 0.628 0.613
60e1eb72b81681d6c856bd7b_uzbeq 1.0 (1.0, 1.0, 1.0) 8.62 20.8 0.706 0.439 0.631 0.435
60e4b1dcd0eedab1e11019d1_4varz 1.0 (1.0, 1.0, 1.0) 8.61 33.0 0.349 0.191 0.368 0.388
60f3261b934093c881b85cf6_lnoph 1.0 (1.0, 1.0, 1.0) 13.37 27.8 0.450 0.225 0.520 0.575
611b1c9ce8ad1ac6db791065_hwlhj 1.0 (1.0, 1.0, 1.0) 8.57 26.1 0.541 0.364 0.231 0.525
613a972033d79df11a6570de_1u773 1.0 (1.0, 1.0, 1.0) 14.71 26.2 0.450 0.209 0.666 0.635
613baa22050360ec21d4437f_9sac0 1.0 (1.0, 1.0, 1.0) 16.64 17.6 0.688 0.106 0.195 0.178
614f681bacfa57e3d06529ad_qv0u7 1.0 (1.0, 1.0, 1.0) 15.65 30.0 0.404 0.256 0.427 0.417
6160f3629ac70cba36523ff8_zslcv 1.0 (1.0, 1.0, 1.0) 9.14 23.4 0.523 0.366 0.416 0.444
5c00043a6d931200019bcb9b_wnj27 1.0 (1.0, 1.0, 1.0) 20.36 34.7 0.284 0.543 0.582 0.634
5d3f63a92df9f7001bd92a32_oj5t7 1.0 (1.0, 1.0, 1.0) 7.93 20.1 0.523 0.193 0.390 0.431
5db9b910001ffa0188426dca_knhee 1.0 (1.0, 1.0, 1.0) 6.05 25.5 0.596 0.134 0.169 0.148
5ecd37ee75736a068808fa6c_v4ej4 1.0 (1.0, 1.0, 1.0) 10.52 16.0 0.468 0.217 0.612 0.536
5fdfd04b9bf07d83b2e5f780_gtb9u 1.0 (1.0, 1.0, 1.0) 9.30 20.6 0.147 0.222 0.657 0.620
6107133e49bf8db00bd6d389_qkj9f 1.0 (1.0, 1.0, 1.0) 11.38 29.6 0.477 0.366 0.299 0.579
613a69d8ed1c11f70b3d37c7_yu0z2 1.0 (1.0, 1.0, 1.0) 11.16 28.9 0.477 0.235 0.372 0.415
6146385561e8f95ff4f3b5d6_cvm6o 1.0 (1.0, 1.0, 1.0) 9.13 24.9 0.642 0.197 0.405 0.346
614b55e22ff3944a165736bb_cl98h 1.0 (1.0, 1.0, 1.0) 14.66 22.6 0.450 0.441 0.580 0.514
616cb46402d68cdfc6e8c8db_xzyj4 1.0 (1.0, 1.0, 1.0) 4.59 25.4 0.211 0.000 0.217 0.188
6294ce94ea81c4554b141010_u5v5t 1.0 (1.0, 1.0, 1.0) 8.28 18.7 0.339 0.294 0.491 0.461
558fa9dffdf99b7ce2924662_58ffp 1.0 (1.0, 1.0, 1.0) 10.06 34.9 0.624 0.314 0.451 0.470
572b96ba3ab9df000dbb4461_bq660 1.0 (1.0, 1.0, 1.0) 14.16 16.5 0.202 0.059 0.513 0.540
57b8e70f35624400013d690c_boeew 1.0 (1.0, 1.0, 1.0) 5.71 19.7 0.440 0.402 0.550 0.589
59501095c58c85000101dc57_od0ny 1.0 (1.0, 1.0, 1.0) 5.81 26.6 0.541 0.377 0.495 0.458
595bd5c85ae9a80001ce3426_32tr4 1.0 (1.0, 1.0, 1.0) 8.43 19.4 0.413 0.259 0.477 0.549
5a7875355292b80001227f63_uh6o3 1.0 (1.0, 1.0, 1.0) 11.53 24.4 0.450 0.399 0.513 0.474
5baf6705848bbd0001d6fc8a_kahs0 1.0 (1.0, 1.0, 1.0) 12.03 32.5 0.486 0.266 0.482 0.531
5c573e54e9813700018acc31_kv5lw 1.0 (1.0, 1.0, 1.0) 6.72 23.6 0.514 0.342 0.415 0.396
5dbd7193e8add82b72d795f2_8g8wk 1.0 (1.0, 1.0, 1.0) 11.12 22.9 0.266 0.461 0.577 0.624
5de476f9b5b7ff447db5c4aa_chlcj 1.0 (1.0, 1.0, 1.0) 10.25 17.6 0.468 0.307 0.514 0.459
5e7bcff00fb32c0f51fea882_bvbwo 1.0 (1.0, 1.0, 1.0) 15.14 19.2 0.229 0.207 0.485 0.490
5e8dddaf3d1b57068b77b2f2_8ebal 1.0 (1.0, 1.0, 1.0) 12.53 32.1 0.404 0.507 0.540 0.636
5eb170206e577a07e9954c65_csm2p 1.0 (1.0, 1.0, 1.0) 15.61 23.0 0.459 0.477 0.688 0.718
5ece75528f582a08555e0a3e_21ckq 1.0 (1.0, 1.0, 1.0) 13.74 48.5 0.523 0.453 0.500 0.613
5ef0a866cd9cde0fcd0d2f77_rvy90 1.0 (1.0, 1.0, 1.0) 10.57 26.2 0.532 0.200 0.599 0.597
5f09068244f84c18faaa74bc_q0ukp 1.0 (1.0, 1.0, 1.0) 6.97 19.3 0.450 -0.031 0.467 0.496
5f108dea719866356702d26f_p836j 1.0 (1.0, 1.0, 1.0) 5.29 17.4 0.422 -0.226 0.413 0.422
5f49424d243bb347aaec4897_ggzqw 1.0 (1.0, 1.0, 1.0) 8.61 25.3 0.303 0.434 0.518 0.475
5f5e7de4c81d3672642cd612_hpyto 1.0 (1.0, 1.0, 1.0) 7.09 19.1 0.532 0.269 0.524 0.300
5f600669b846780f0fe45709_erd2u 1.0 (1.0, 1.0, 1.0) 13.40 31.0 0.514 0.310 0.587 0.645
5f761e5106b786071f45b4aa_78zle 1.0 (1.0, 1.0, 1.0) 11.56 27.8 0.385 0.048 0.207 0.219
5f7ebad5cf009c196fd54b2b_d68uh 1.0 (1.0, 1.0, 1.0) 8.39 15.6 0.495 0.404 0.674 0.659
5f97e6601f6d0e016087fc91_h6pvt 1.0 (1.0, 1.0, 1.0) 4.71 26.9 0.239 0.051 0.166 0.289
5f9aba6600cdf11f1c9b915c_cakh2 1.0 (1.0, 1.0, 1.0) 26.74 46.8 0.394 0.266 0.325 0.357
5fb633dfaeda3f0aa05eefad_4t92s 1.0 (1.0, 1.0, 1.0) 8.18 18.1 0.505 0.289 0.521 0.499
5ff4a242cbe069bc27d9278b_relyq 1.0 (1.0, 1.0, 1.0) 6.51 14.0 0.183 0.225 0.572 0.540
603f6e643234e512fc197ae1_vowxj 1.0 (1.0, 1.0, 1.0) 11.40 32.7 0.486 0.304 0.538 0.281
6045cb37ffdadc70e734a73b_ns96q 1.0 (1.0, 1.0, 1.0) 17.87 52.2 0.541 0.448 0.427 0.429
604b169fe4b7991ec08da3a6_9o72l 1.0 (1.0, 1.0, 1.0) 7.21 23.4 0.330 0.111 0.456 0.419
605a1c7fe0ca143242990e95_528pg 1.0 (1.0, 1.0, 1.0) 13.97 23.1 0.560 0.388 0.491 0.526
6081728972120aa7f9685791_aqvhb 1.0 (1.0, 1.0, 1.0) 25.43 41.3 0.578 0.312 0.494 0.573
6099df8e57bf74dbc121c774_5jnsc 1.0 (1.0, 1.0, 1.0) 6.22 26.6 0.459 0.510 0.502 0.512
60a6ba026f8bd75b67b23c97_z458q 1.0 (1.0, 1.0, 1.0) 11.75 14.6 0.596 0.241 0.475 0.518
60b8b5dcb46db8ae98d0b047_4u9jy 1.0 (1.0, 1.0, 1.0) 4.86 21.4 0.367 0.151 -0.220 0.445
60cefa69352cbf2549f2bf35_as90e 1.0 (1.0, 1.0, 1.0) 8.50 19.2 0.486 0.513 0.539 0.520
60ddfb3db6a71ad9ba75e387_u85bv 1.0 (1.0, 1.0, 1.0) 8.48 14.7 0.550 0.068 0.502 0.435
61081aab1dad0a92827a371d_bbpfc 1.0 (1.0, 1.0, 1.0) 8.87 21.6 0.486 0.285 0.561 0.532
61093d97f7bf8a4f8117eb82_yzsmx 1.0 (1.0, 1.0, 1.0) 13.15 24.5 0.550 0.122 0.259 0.316
610d97bf0ee9babdb89986ea_3t039 1.0 (1.0, 1.0, 1.0) 8.71 20.4 0.450 0.527 0.584 0.556
61253683f41abc76c81ec082_xc4uu 1.0 (1.0, 1.0, 1.0) 7.45 19.6 0.294 0.346 0.559 0.546
612ba6c594a6d54154a88ae7_m0duf 1.0 (1.0, 1.0, 1.0) 6.73 12.5 0.339 0.513 0.508 0.445
61330f324c6c15a907dc2706_zg72v 1.0 (1.0, 1.0, 1.0) 9.53 28.0 0.404 0.252 0.432 0.495
613af39692992acbacdbbbbc_0g94n 1.0 (1.0, 1.0, 1.0) 17.26 39.3 0.394 0.112 0.458 0.518
6151a21b24b1ef1bc130b97d_cazbl 1.0 (1.0, 1.0, 1.0) 14.07 24.8 0.615 0.050 0.371 0.359
61545919a17f1331cb7b33a7_mszfq 1.0 (1.0, 1.0, 1.0) 12.28 20.4 0.018 0.182 0.359 0.376
61687ebcd2a35ffb762d1928_0hgcq 1.0 (1.0, 1.0, 1.0) 13.01 40.4 0.413 0.299 0.496 0.557
616e5ae706e970fe0aff99b6_561t0 1.0 (1.0, 1.0, 1.0) 6.15 25.2 0.624 0.453 0.548 0.497
6266a4e5846e1e41812a0432_ds50m 1.0 (1.0, 1.0, 1.0) 6.33 16.5 0.477 0.201 0.502 0.488
62e416f154e4c9e7f39d5cf7_2a9nx 1.0 (1.0, 1.0, 1.0) 6.52 9.3 0.468 0.089 0.434 0.443
5ec554706960444f4a1768de_uma91 1.0 (1.0, 1.0, 1.0) 8.58 16.4 0.248 -0.142 0.188 0.513
610aa32712b5d159232e01ca_2qade 1.0 (1.0, 1.0, 1.0) 6.85 20.9 0.523 0.403 0.548 0.556
5e3e11a36a0b8a000c609d5e_zsvqx 1.0 (1.0, 1.0, 1.0) 14.11 18.2 0.550 0.300 0.598 0.571
5ec87daedce2260008f5c0d3_w91o3 1.0 (1.0, 1.0, 1.0) 8.43 26.4 0.339 0.505 0.124 0.524
5f6aca6b9b8c12072e3b670c_vywjw 1.0 (1.0, 1.0, 1.0) 17.96 35.0 0.413 0.454 0.441 0.495
5f97a755a31f2717b0220d23_gqyj4 1.0 (1.0, 1.0, 1.0) 12.71 19.5 0.532 0.319 0.461 0.466
5fb754ca012e372845878671_xbv3b 1.0 (1.0, 1.0, 1.0) 11.34 19.4 0.514 0.510 0.464 0.512
601857c3c3f5ce0c3e5fb913_cvnls 1.0 (1.0, 1.0, 1.0) 32.80 22.6 0.431 0.200 0.529 0.487
602825b9e6f7593201d8c61b_4kogk 1.0 (1.0, 1.0, 1.0) 16.29 20.0 0.422 0.242 0.549 0.283
60c11517da9e1fd6d9a22339_wkhqh 1.0 (1.0, 1.0, 1.0) 5.98 17.4 0.394 0.247 0.512 0.497
60fe250b3984cfdf32c05860_l0zk5 1.0 (1.0, 1.0, 1.0) 11.19 25.0 0.505 0.252 0.469 0.463
613a541cf948d295c1df8752_6456u 1.0 (1.0, 1.0, 1.0) 8.09 36.3 0.495 0.351 0.427 0.344
613aef3d9041bcd28952af82_yt54b 1.0 (1.0, 1.0, 1.0) 12.64 28.9 0.349 0.345 0.540 0.570
613ffdd2bb5bf78fdfe4f6bd_nu3me 1.0 (1.0, 1.0, 1.0) 7.87 30.0 0.642 0.442 0.307 0.447
614a4cb5e867680562f258a0_dq5q6 1.0 (1.0, 1.0, 1.0) 12.30 24.1 0.385 0.345 0.607 0.601
6163af4e6672fb3862f2ae39_jugfp 1.0 (1.0, 1.0, 1.0) 12.92 26.3 0.440 0.362 0.603 0.426
629534afc0924e49e1464589_oy31o 1.0 (1.0, 1.0, 1.0) 4.98 16.6 0.569 0.154 0.462 0.439
5b7d020d4ba9cd0001e6a731_3jexa 1.0 (1.0, 1.0, 1.0) 20.05 35.1 0.541 0.184 0.514 0.405
5b94d723839c0a00010f88d9_gve2u 1.0 (1.0, 1.0, 1.0) 11.26 11.8 0.330 -0.108 0.466 0.472
5bcf309b15678a00017fcccb_mnl11 1.0 (1.0, 1.0, 1.0) 14.06 22.1 0.294 0.196 0.390 0.391
5c6f0e238e9bdd0001f6b65b_xydcz 1.0 (1.0, 1.0, 1.0) 7.98 22.6 0.495 0.020 0.421 0.395
5c97e7136825d900019b9fb8_r65ed 1.0 (1.0, 1.0, 1.0) 10.56 14.4 0.404 0.279 0.481 0.482
5cabf58293e29a0016018c30_t937s 1.0 (1.0, 1.0, 1.0) 6.91 16.4 0.560 0.143 0.372 0.438
5e1e5c3c80e02e1c36679187_jerrz 1.0 (1.0, 1.0, 1.0) 14.03 30.6 0.459 0.131 0.168 0.210
5e541f4f6567b5423b7808c5_2k0mr 1.0 (1.0, 1.0, 1.0) 11.25 36.7 0.532 0.339 0.643 0.623
5ebde9baaefecd1325ef23c7_xmfug 1.0 (1.0, 1.0, 1.0) 21.98 43.9 0.101 0.504 -0.058 0.597
5ecce2f70ecf8e0009a4296c_eau95 1.0 (1.0, 1.0, 1.0) 6.06 16.2 0.339 0.309 0.489 0.297
5f09cb729bf14505753e5bd8_em3yr 1.0 (1.0, 1.0, 1.0) 14.74 24.4 0.202 0.427 0.481 0.607
5f4469a101c96e20702a9ece_91rtn 1.0 (1.0, 1.0, 1.0) 13.51 26.9 0.495 0.562 0.517 0.445
5f516d96bf6cde3b04b94b69_w7dln 1.0 (1.0, 1.0, 1.0) 7.85 12.9 0.349 0.241 0.356 0.334
5fb40df961ccbf0360d60728_rvkp1 1.0 (1.0, 1.0, 1.0) 13.44 21.9 0.514 0.195 0.446 0.305
607de1d480f76e94ffb6e0ab_nl96p 1.0 (1.0, 1.0, 1.0) 12.01 17.1 0.257 0.462 0.542 0.405
60aa4b9356c591511cc09f5f_7096w 1.0 (1.0, 1.0, 1.0) 10.96 25.7 0.615 0.296 0.498 0.472
60d333a37d135f2ee2592457_0dw42 1.0 (1.0, 1.0, 1.0) 16.90 46.7 0.422 0.129 0.279 0.275
60eb34f117838a34a29a69d3_rxv85 1.0 (1.0, 1.0, 1.0) 11.40 38.9 0.394 0.285 0.060 0.260
611cdcaeec974368e242cbea_90orb 1.0 (1.0, 1.0, 1.0) 14.58 20.4 0.367 0.286 0.420 0.381
613a9da3c77e45388ba8a4c6_ta4o3 1.0 (1.0, 1.0, 1.0) 9.20 16.3 0.440 0.276 0.435 0.355
615025cfceb970fd5d487a5d_uz8d6 1.0 (1.0, 1.0, 1.0) 10.46 17.4 0.422 0.157 0.478 0.539
615de114da91c7b7988ddf0b_x0h13 1.0 (1.0, 1.0, 1.0) 6.81 18.3 0.523 0.302 0.393 0.397
6164cdedc4b526b72d7b96a1_py21n 1.0 (1.0, 1.0, 1.0) 13.56 28.6 0.303 0.214 0.162 0.506
616be20264dc3d95fa222d53_fycan 1.0 (1.0, 1.0, 1.0) 11.51 22.1 0.404 0.255 0.609 0.610
6303820a6d1a6fcf50e0d808_8lrn4 1.0 (1.0, 1.0, 1.0) 10.98 17.0 0.468 0.157 0.505 0.329
# kableExtra::row_spec(which(str_detect(dfsub$Participant, "613a972033d79df11a6570de")) + 1, background = "green")
p_att <- dfsub |>
  select(Participant, starts_with("Att")) |>
  pivot_longer(-Participant) |>
  # mutate(name = str_remove(name, "Cor_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  scale_color_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Score", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_time <- dfsub |>
  select(Participant, starts_with("Duration")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "Duration_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#4CAF50", "#FF9800")) +
  scale_color_manual(values = c("#4CAF50", "#FF9800")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Duration (min)", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_cor <- dfsub |>
  select(Participant, starts_with("r_")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "r_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  scale_color_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(
      angle = 45, hjust = 1,
      color = ifelse(levels(dfsub$Participant) %in% outliers, "red", ifelse(levels(dfsub$Participant) %in% outliers_partial, "orange", "black"))
    ),
    legend.position = "top"
  ) +
  labs(y = "Correlation", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

(p_att + theme(axis.text.x = element_blank())) /
  (p_time + theme(axis.text.x = element_blank())) /
  (p_cor)


df <- df |>
  filter(!Participant %in% c(outliers))

Participants

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, Age, Sex, Sexual_Orientation, Ethnicity, Education, Nationality, Device_OS, starts_with("Screen"), starts_with("IPIP"), starts_with("Social_"), starts_with("FFNI_"), starts_with("GPTS_"), starts_with("IUS_"), starts_with("SelfAttractiveness"), starts_with("AI"), n_Real, Confidence_Fake, Confidence_Real) |>
  slice(1) |>
  ungroup()

The final sample included 145 participants (Mean age = 28.3, SD = 9.0, range: [19, 66]; Sex: 48.3% females, 51.0% males, 0.7% other; Education: Doctorate, 3.45%; Master, 17.24%; Bachelor, 37.93%; High School, 37.24%; Other, 3.45%; Prefer not to Say, 0.69%).

plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
  dfsub |>
    ggplot(aes_string(x = what)) +
    geom_density(fill = fill) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) +
    ggtitle(title, subtitle = subtitle) +
    theme_modern() +
    theme(
      plot.title = element_text(face = "bold", hjust = 0.5),
      plot.subtitle = element_text(face = "italic", hjust = 0.5),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
}

plot_waffle <- function(dfsub, what = "Nationality", title = what, rows = 7, size = 6) {
  # library(emojifont)
  ggwaffle::waffle_iron(dfsub, what, rows = rows) |>
    # mutate(label = emojifont::fontawesome('fa-smiley')) |>
    # mutate(label = emojifont::emoji('smiley')) |>
    ggplot(aes(x, y)) +
    geom_point(aes(color = group), shape = "square", size = size) +
    # ggwaffle::geom_waffle(color = "white") +
    # geom_point() +
    # geom_text(aes(color=group ,label=label), family='fontawesome-webfont', size=4) +
    # geom_text(aes(color=group ,label=label), family='EmojiOne', size=4) +
    coord_equal() +
    ggtitle(title) +
    labs(fill = "", color = "") +
    # scale_x_continuous(expand = c(0, 0)) +
    # scale_y_continuous(expand = c(0, 0)) +
    theme_void() +
    # ggwaffle::theme_waffle() +
    theme(plot.title = element_text(face = "bold", hjust = 0.5))
}
p1 <- estimate_density(dfsub$Age) |>
  ggplot(aes(x = x, y = y)) +
  geom_area(fill = "#FF9800") +
  labs(x = "Age", y = "") +
  theme_modern()

p2 <- plot_waffle(dfsub, "Sex") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))

p3 <- plot_waffle(dfsub, "Sexual_Orientation")


p4 <- plot_waffle(dfsub, "Education") +
  scale_fill_viridis_d()

p5 <- dfsub |>
  group_by(Nationality) |>
  mutate(n = n()) |>
  ungroup() |>
  mutate(Nationality = fct_reorder(Nationality, desc(n))) |>
  ggplot(aes(Nationality)) +
  geom_bar(aes(fill = Nationality)) +
  scale_fill_viridis_d(guide = "none") + 
  theme_modern() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) 

p6 <- plot_waffle(dfsub, "Ethnicity") +
  scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0", "Mixed" = "#795548"))

p7 <- plot_waffle(dfsub, "Screen_Resolution", title = "Screen Resolution") +
  scale_fill_pizza_d() +
  guides(fill = "none")

p8 <- plot_waffle(dfsub, "Device_OS", title = "Device OS") +
  scale_fill_bluebrown_d()

# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
#   scale_fill_viridis_d()

patchwork::wrap_plots(list(p1, p2, p3, p5, p4, p6))

Results

Manipulation Check

Real / Fake

# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
  mutate(Participant = fct_relevel(Participant, df |>
    group_by(Participant) |>
    summarize(Belief_Answer = mean(Belief_Answer)) |>
    ungroup() |>
    arrange(Belief_Answer) |>
    pull(Participant) |>
    as.character())) |>
  # mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
  ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
  geom_vline(xintercept = 0, linetype = "dotted") +
  scale_y_discrete(expand = c(0.02, 0)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-0.95, 0, 0.95),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d() +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "grey", color = "white") +
  ggside::scale_xsidey_continuous(expand = c(0, 0))



df |> 
  group_by(Participant, Belief) |> 
  summarize(n = n() / 108, 
            Confidence = mean(Belief_Confidence)) |> 
  pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |> 
  ungroup() |> 
  describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
## 
## Parameter       | Mean |       95% CI
## -------------------------------------
## n_Fake          | 0.44 | [0.12, 0.64]
## n_Real          | 0.56 | [0.36, 0.88]
## Confidence_Fake | 0.60 | [0.24, 1.00]
## Confidence_Real | 0.59 | [0.19, 0.98]


m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.090
## Stimulus    | 0.096

Colinearity

IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")

correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
## 
## Parameter1  |  Parameter2 |         r |        95% CI | t(15658) |         p
## ----------------------------------------------------------------------------
## Attractive  |      Beauty |      0.64 | [ 0.64, 0.65] |   105.41 | < .001***
## Attractive  | Trustworthy |      0.10 | [ 0.08, 0.11] |    12.28 | < .001***
## Attractive  |    Familiar |      0.16 | [ 0.14, 0.17] |    19.65 | < .001***
## Beauty      | Trustworthy |      0.25 | [ 0.23, 0.26] |    32.01 | < .001***
## Beauty      |    Familiar | -8.56e-03 | [-0.02, 0.01] |    -1.07 | 0.284    
## Trustworthy |    Familiar |      0.07 | [ 0.06, 0.09] |     8.98 | < .001***
## 
## p-value adjustment method: Holm (1979)
## Observations: 15660
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
  for (y in IVs) {
    if (x == y) next
    print(paste(y, "~", x))
    model <- glmmTMB::glmmTMB(as.formula(
      paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
    ),
    data = df,
    family = glmmTMB::beta_family()
    )

    # model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
    #                     random = list(Participant=~1, Stimulus=~1),
    #                     data = df,
    #                     family=mgcv::betar())

    pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
    pred$y <- y
    pred <- data_rename(pred, x, "Score")
    pred$x <- x
    preds <- rbind(preds, pred)

    dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
  }
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"

dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
  ggplot(aes(x = Score, y = Predicted)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  # geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
  geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
  scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
  scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  facet_grid(y ~ x, switch = "both") +
  theme_modern() +
  labs(title = "Collinearity in the Stimuli Ratings") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggnewscale::new_scale_fill() +
  scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")

Effect of Delay

model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
  data = df,
  family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)

m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
  data = df,
  family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
  mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))


df |>
  ggplot(aes(x = Delay, y = Real)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  geom_hline(yintercept = 0.5, linetype = "dotted") +
  # geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
  geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = pred, aes(y = Predicted), color = "red") +
  scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  theme_modern() +
  labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "#795548", color = "white") +
  ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")


hdi(df$Delay)
## 95% HDI: [1.28, 29.66]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
## 
## Delay | Participant | Stimulus | Predicted |   SE |       95% CI
## ----------------------------------------------------------------
## 0.00  |             |          |      0.58 | 0.02 | [0.54, 0.63]
## 60.00 |             |          |      0.54 | 0.03 | [0.47, 0.60]
## 
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)

parameters::parameters(model, effects="fixed", exponentiate=TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.41 0.12 (1.19, 1.67) 3.90 < .001
Delay 1.00 2.45e-03 (0.99, 1.00) -1.37 0.172
parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.79 0.09 (0.61, 0.97) 8.56 < .001
Belief (Real) -0.05 0.07 (-0.18, 0.09) -0.68 0.498
Belief (Fake) x Delay -2.67e-03 2.38e-03 (-7.34e-03, 2.00e-03) -1.12 0.263
Belief (Real) x Delay -5.92e-03 2.07e-03 (-9.98e-03, -1.85e-03) -2.85 0.004

Determinants of Reality

make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
  # Models
  m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
    data = df,
    family = "binomial"
  )
  y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
  # gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
  #                  data=df,
  #                  algorithm="sampling",
  #                  family = "bernoulli")
  # trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
  # slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
  # trend$Trend <- interpret_pd(slope$pd)
  # trend$group <- 0
  # trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))


  m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
    data = df,
    family = glmmTMB::beta_family()
  )
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  sig1 <- data.frame(x = 0.5, 
                     y = y_real[c(11, 31), "Predicted"],
                     Sex = y_real[c(11, 31), "Sex"])
  param <- parameters::parameters(m_real, effects = "fixed", keep = var)
  sig1$p <- c(min(param[str_detect(param$Parameter, sig1$Sex[1]), "p"]), min(param[str_detect(param$Parameter, sig1$Sex[2]), "p"]))
  sig1$y <- sig1$y + ifelse(sig1$Sex == "Male", -0.03, 0.03)
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  
  sig2 <- data.frame(x = 0.5, 
                     y =  y_conf[c(11, 31, 51, 71), "Predicted"],
                     Sex = y_conf[c(11, 31, 51, 71), "Sex"],
                     Belief = y_conf[c(11, 31, 51, 71), "Belief"]) |> 
    arrange(Sex, Belief)
  param <- parameters::parameters(m_conf, effects = "fixed", keep = var) |> 
    arrange(Parameter)
  sig2$p <- c(min(param$p[c(1, 2)]), min(param$p[c(5, 6)]), min(param$p[c(3, 4)]), min(param$p[c(7, 8)]))
  sig2$y <- sig2$y + ifelse(sig2$Belief == "Real", 0.03, -0.03)
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
    scale_fill_gradientn(colors = c("white", fill), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    # geom_point2(alpha = 0.25, size = 4, color = "black") +
    geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
    geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
    geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
    # geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
    # geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
    geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
    scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(aes(fill = Sex), alpha=2/3, color = NA) +
    ggside::geom_ysidedensity(aes(fill = Sex), alpha=2/3, color = NA) +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
  var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
  var = "Familiar", fill = "#2196F3"
)

Attractiveness

parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x poly(Attractive, 2)1 4.98 3.19 (-1.27, 11.23) 1.56 0.118
Sex (Male) x poly(Attractive, 2)1 16.57 4.72 (7.33, 25.82) 3.51 < .001
Sex (Female) x poly(Attractive, 2)2 7.82 3.07 (1.81, 13.84) 2.55 0.011
Sex (Male) x poly(Attractive, 2)2 2.95 5.56 (-7.95, 13.85) 0.53 0.596
performance::performance(rez_at$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.17 0.02
performance::icc(rez_at$model_belief, by_group = TRUE)  |> 
  display()
Group ICC
Participant 0.07
Stimulus 0.08
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive")  |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) x SexFemale x poly(Attractive, 2)1 0.41 2.25 (-4.01, 4.83) 0.18 0.855
Belief (Real) x SexFemale x poly(Attractive, 2)1 2.40 1.79 (-1.11, 5.91) 1.34 0.181
Belief (Fake) x SexMale x poly(Attractive, 2)1 1.97 3.72 (-5.32, 9.25) 0.53 0.597
Belief (Real) x SexMale x poly(Attractive, 2)1 0.92 2.91 (-4.79, 6.63) 0.31 0.753
Belief (Fake) x SexFemale x poly(Attractive, 2)2 5.23 2.23 (0.86, 9.60) 2.35 0.019
Belief (Real) x SexFemale x poly(Attractive, 2)2 4.30 1.70 (0.97, 7.64) 2.53 0.011
Belief (Fake) x SexMale x poly(Attractive, 2)2 -9.92 4.62 (-18.99, -0.86) -2.15 0.032
Belief (Real) x SexMale x poly(Attractive, 2)2 5.46 3.12 (-0.64, 11.57) 1.75 0.080

rez_at$p

Beauty

parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x poly(Beauty, 2)1 3.72 3.43 (-2.99, 10.43) 1.09 0.278
Sex (Male) x poly(Beauty, 2)1 11.82 4.28 (3.44, 20.21) 2.76 0.006
Sex (Female) x poly(Beauty, 2)2 4.46 3.14 (-1.69, 10.61) 1.42 0.156
Sex (Male) x poly(Beauty, 2)2 7.65 4.69 (-1.55, 16.85) 1.63 0.103
performance::performance(rez_gl$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.17 0.02
performance::icc(rez_gl$model_belief, by_group = TRUE)|> 
  display()
Group ICC
Participant 0.07
Stimulus 0.08
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) x SexFemale x poly(Beauty, 2)1 -1.16 2.30 (-5.68, 3.35) -0.51 0.613
Belief (Real) x SexFemale x poly(Beauty, 2)1 3.33 1.96 (-0.51, 7.16) 1.70 0.089
Belief (Fake) x SexMale x poly(Beauty, 2)1 -0.95 3.34 (-7.49, 5.59) -0.28 0.776
Belief (Real) x SexMale x poly(Beauty, 2)1 2.15 2.58 (-2.90, 7.20) 0.83 0.404
Belief (Fake) x SexFemale x poly(Beauty, 2)2 7.84 2.27 (3.39, 12.29) 3.46 < .001
Belief (Real) x SexFemale x poly(Beauty, 2)2 2.15 1.88 (-1.53, 5.83) 1.15 0.251
Belief (Fake) x SexMale x poly(Beauty, 2)2 -6.50 3.50 (-13.36, 0.37) -1.85 0.064
Belief (Real) x SexMale x poly(Beauty, 2)2 4.67 2.71 (-0.64, 9.98) 1.72 0.085

rez_gl$p

Trustworthiness

parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x poly(Trustworthy, 2)1 6.44 3.34 (-0.11, 13.00) 1.93 0.054
Sex (Male) x poly(Trustworthy, 2)1 5.86 4.14 (-2.26, 13.98) 1.41 0.157
Sex (Female) x poly(Trustworthy, 2)2 -0.21 3.31 (-6.69, 6.27) -0.06 0.950
Sex (Male) x poly(Trustworthy, 2)2 1.20 4.32 (-7.27, 9.67) 0.28 0.781
performance::performance(rez_tr$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.16 0.02
performance::icc(rez_tr$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.07
Stimulus 0.08
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) x SexFemale x poly(Trustworthy, 2)1 -0.63 2.26 (-5.07, 3.80) -0.28 0.780
Belief (Real) x SexFemale x poly(Trustworthy, 2)1 1.84 2.15 (-2.37, 6.05) 0.86 0.392
Belief (Fake) x SexMale x poly(Trustworthy, 2)1 -3.07 3.12 (-9.19, 3.06) -0.98 0.326
Belief (Real) x SexMale x poly(Trustworthy, 2)1 0.47 2.51 (-4.46, 5.40) 0.19 0.853
Belief (Fake) x SexFemale x poly(Trustworthy, 2)2 6.12 2.36 (1.49, 10.75) 2.59 0.010
Belief (Real) x SexFemale x poly(Trustworthy, 2)2 6.14 2.04 (2.13, 10.14) 3.00 0.003
Belief (Fake) x SexMale x poly(Trustworthy, 2)2 -3.63 3.07 (-9.65, 2.39) -1.18 0.237
Belief (Real) x SexMale x poly(Trustworthy, 2)2 1.41 2.60 (-3.69, 6.51) 0.54 0.589

rez_tr$p

Familiarity

parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x poly(Familiar, 2)1 0.49 3.62 (-6.61, 7.59) 0.13 0.893
Sex (Male) x poly(Familiar, 2)1 9.24 5.18 (-0.92, 19.40) 1.78 0.075
Sex (Female) x poly(Familiar, 2)2 -0.41 3.31 (-6.90, 6.09) -0.12 0.902
Sex (Male) x poly(Familiar, 2)2 -0.82 5.04 (-10.69, 9.06) -0.16 0.871
performance::performance(rez_fa$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.17 0.02
performance::icc(rez_fa$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.07
Stimulus 0.08
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) x SexFemale x poly(Familiar, 2)1 2.04 2.47 (-2.80, 6.88) 0.83 0.408
Belief (Real) x SexFemale x poly(Familiar, 2)1 -0.64 2.04 (-4.64, 3.35) -0.32 0.753
Belief (Fake) x SexMale x poly(Familiar, 2)1 -12.41 4.01 (-20.27, -4.54) -3.09 0.002
Belief (Real) x SexMale x poly(Familiar, 2)1 9.98 3.14 (3.83, 16.13) 3.18 0.001
Belief (Fake) x SexFemale x poly(Familiar, 2)2 0.14 2.31 (-4.39, 4.67) 0.06 0.952
Belief (Real) x SexFemale x poly(Familiar, 2)2 -1.04 1.94 (-4.85, 2.77) -0.54 0.592
Belief (Fake) x SexMale x poly(Familiar, 2)2 4.79 4.22 (-3.49, 13.06) 1.13 0.257
Belief (Real) x SexMale x poly(Familiar, 2)2 -0.28 2.96 (-6.08, 5.52) -0.10 0.924

rez_fa$p

Interaction with Self-Attractiveness

cor_test(dfsub, "SelfAttractiveness1", "SelfAttractiveness2")
## Parameter1          |          Parameter2 |    r |       95% CI | t(143) |         p
## ------------------------------------------------------------------------------------
## SelfAttractiveness1 | SelfAttractiveness2 | 0.90 | [0.86, 0.93] |  24.35 | < .001***
## 
## Observations: 145

df$Self_Attractiveness <- rowMeans(df[c("SelfAttractiveness1", "SelfAttractiveness2")])
m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Attractive, 2) * Self_Attractiveness) + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x Self Attractiveness 0.64 0.71 (-0.74, 2.03) 0.91 0.364
Sex (Male) x Self Attractiveness -2.02 1.53 (-5.02, 0.98) -1.32 0.188
Sex (Female) x poly(Attractive, 2)1 x Self Attractiveness -0.74 16.99 (-34.03, 32.55) -0.04 0.965
Sex (Male) x poly(Attractive, 2)1 x Self Attractiveness 36.09 37.11 (-36.65, 108.83) 0.97 0.331
Sex (Female) x poly(Attractive, 2)2 x Self Attractiveness -1.47 12.55 (-26.08, 23.13) -0.12 0.907
Sex (Male) x poly(Attractive, 2)2 x Self Attractiveness -9.16 36.32 (-80.35, 62.02) -0.25 0.801


m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Beauty, 2) * Self_Attractiveness) + Trustworthy + Familiar + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) x Self Attractiveness 0.64 0.76 (-0.84, 2.13) 0.85 0.397
Sex (Male) x Self Attractiveness -1.63 1.59 (-4.75, 1.48) -1.03 0.304
Sex (Female) x poly(Beauty, 2)1 x Self Attractiveness -13.48 15.05 (-42.98, 16.01) -0.90 0.370
Sex (Male) x poly(Beauty, 2)1 x Self Attractiveness 46.46 31.95 (-16.15, 109.08) 1.45 0.146
Sex (Female) x poly(Beauty, 2)2 x Self Attractiveness 7.63 12.72 (-17.30, 32.56) 0.60 0.549
Sex (Male) x poly(Beauty, 2)2 x Self Attractiveness -2.87 32.28 (-66.15, 60.40) -0.09 0.929

Inter-Individual Correlates

plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
  y_real <- estimate_relation(m_real, at = c(var), length = 21)
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
  
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
  sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
                     p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
                     p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
                     Belief = y_conf[c(11, 31), "Belief"])
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  # Data
  dat <- insight::get_data(m_conf) |> 
                  group_by(Participant, Belief) |> 
                  data_select(c("Participant", "Belief", var, "Belief_Confidence")) |> 
                  mean_qi(.width = 0.5) |> 
    mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
    ggnewscale::new_scale_fill() +
    stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
    geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
    geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
    geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
    geom_line(data = y_real, aes(y = Predicted), size=1) +
    geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
    scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
    ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  p
}
make_correlation <- function(x, y) {
  cor <- correlation::correlation(x,
    y,
    bayesian = TRUE,
    bayesian_prior = "medium.narrow",
    sort = TRUE
  ) |>
    datawizard::data_remove(c("ROPE_Percentage"))
  cor$`BF (Spearman)` <- format_bf(
    correlation::correlation(
      x, y,
      bayesian = TRUE,
      ranktransform = TRUE,
      bayesian_prior = "medium.narrow"
    )$BF,
    name = NULL, stars = TRUE
  )
  cor |>
    arrange(desc(BF))
}
analyze_interindividual <- function(df, questionnaire = "IPIP6_") {
  param_real <- data.frame()
  param_conf <- data.frame()
  for(var in names(select(df, starts_with(questionnaire)))) {
    m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", var)), 
                               data=datawizard::standardise(df, select=var), family = "binomial")
    param_real <- rbind(param_real, parameters::parameters(m_real, effects="fixed")[2, ])
    
    m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", var)), 
                             
                               data=datawizard::standardise(df, select=var), 
                             family = glmmTMB::beta_family())
  
    param_conf <- rbind(param_conf, parameters::parameters(m_conf, effects="fixed")[3:4, ])
  }
  
  param_real <- param_real |> 
    mutate(Parameter = str_remove(Parameter, questionnaire)) |> 
    select(-SE)
  param_conf <- param_conf |> 
    tidyr::separate("Parameter", into = c("Belief", "Dimension"), sep = ":") |> 
    mutate(Belief = str_remove(Belief, "Belief"),
           Dimension = str_remove(Dimension, questionnaire)) |> 
    select(-SE)
  list(param_real, param_conf)
}

IPIP-6

f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.96 0.91 (0.79, 4.88) 1.45 0.147
IPIP6 Extraversion 0.74 0.20 (0.43, 1.27) -1.10 0.272
IPIP6 Conscientiousness 0.90 0.25 (0.52, 1.55) -0.39 0.695
IPIP6 Neuroticism 0.72 0.23 (0.39, 1.34) -1.03 0.302
IPIP6 Openness 0.96 0.31 (0.51, 1.82) -0.11 0.909
IPIP6 HonestyHumility 0.70 0.20 (0.39, 1.23) -1.24 0.215
IPIP6 Agreeableness 1.31 0.45 (0.67, 2.57) 0.80 0.424


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.21 0.75 (-1.27, 1.69) 0.28 0.781
Belief (Real) 0.17 0.16 (-0.14, 0.48) 1.10 0.271
Belief (Fake) x IPIP6 Extraversion -0.10 0.45 (-0.98, 0.78) -0.22 0.824
Belief (Real) x IPIP6 Extraversion -0.23 0.45 (-1.10, 0.65) -0.51 0.613
Belief (Fake) x IPIP6 Conscientiousness -0.12 0.46 (-1.02, 0.78) -0.27 0.790
Belief (Real) x IPIP6 Conscientiousness 0.04 0.46 (-0.85, 0.94) 0.09 0.927
Belief (Fake) x IPIP6 Neuroticism 0.25 0.51 (-0.75, 1.26) 0.49 0.622
Belief (Real) x IPIP6 Neuroticism 0.38 0.51 (-0.62, 1.38) 0.74 0.460
Belief (Fake) x IPIP6 Openness 0.76 0.53 (-0.28, 1.80) 1.43 0.152
Belief (Real) x IPIP6 Openness 0.37 0.53 (-0.67, 1.40) 0.69 0.488
Belief (Fake) x IPIP6 HonestyHumility -1.16 0.47 (-2.09, -0.23) -2.45 0.014
Belief (Real) x IPIP6 HonestyHumility -1.62 0.47 (-2.55, -0.70) -3.43 < .001
Belief (Fake) x IPIP6 Agreeableness 0.88 0.56 (-0.21, 1.98) 1.58 0.114
Belief (Real) x IPIP6 Agreeableness 1.01 0.56 (-0.09, 2.10) 1.81 0.071

p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip

sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |            Parameter2 |   rho |         95% CI |       pd |               Prior |    BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.37, -0.06] | 99.35%** | Beta (5.20 +- 5.20) | 9.41* |         6.32*
## Confidence_Fake |        IPIP6_Openness |  0.15 | [ 0.01,  0.31] |  97.70%* | Beta (5.20 +- 5.20) |  1.72 |          2.98
## Confidence_Fake | IPIP6_HonestyHumility | -0.15 | [-0.30,  0.02] |   96.10% | Beta (5.20 +- 5.20) |  1.38 |         0.683
## Confidence_Fake |    IPIP6_Extraversion |  0.14 | [-0.02,  0.30] |   95.97% | Beta (5.20 +- 5.20) |  1.14 |          1.53
## 
## Observations: 145

Narcissism

f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.23 0.40 (0.65, 2.33) 0.62 0.533
FFNI AcclaimSeeking 2.24 0.74 (1.17, 4.27) 2.44 0.015
FFNI Arrogance 1.08 0.35 (0.57, 2.05) 0.25 0.803
FFNI Authoritativeness 1.01 0.32 (0.54, 1.86) 0.02 0.986
FFNI Distrust 1.25 0.35 (0.72, 2.17) 0.78 0.437
FFNI Entitlement 0.66 0.22 (0.34, 1.28) -1.23 0.219
FFNI Exhibitionism 1.00 0.29 (0.57, 1.76) -6.20e-04 > .999
FFNI Exploitativeness 1.14 0.32 (0.66, 1.98) 0.48 0.634
FFNI GrandioseFantasies 0.87 0.20 (0.55, 1.38) -0.58 0.563
FFNI Indifference 0.86 0.25 (0.48, 1.54) -0.50 0.614
FFNI LackOfEmpathy 1.24 0.39 (0.67, 2.31) 0.68 0.498
FFNI Manipulativeness 0.47 0.15 (0.25, 0.87) -2.40 0.017
FFNI NeedForAdmiration 0.86 0.27 (0.47, 1.59) -0.47 0.636
FFNI ReactiveAnger 1.40 0.38 (0.82, 2.37) 1.24 0.217
FFNI Shame 0.71 0.24 (0.37, 1.38) -1.00 0.317
FFNI ThrillSeeking 1.04 0.23 (0.68, 1.60) 0.18 0.855


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.56 0.53 (-0.47, 1.59) 1.06 0.289
Belief (Real) -0.20 0.12 (-0.43, 0.02) -1.74 0.081
Belief (Fake) x FFNI AcclaimSeeking 1.62 0.54 (0.56, 2.68) 3.00 0.003
Belief (Real) x FFNI AcclaimSeeking 1.65 0.54 (0.59, 2.70) 3.07 0.002
Belief (Fake) x FFNI Arrogance -0.41 0.53 (-1.45, 0.64) -0.76 0.447
Belief (Real) x FFNI Arrogance -0.63 0.53 (-1.68, 0.41) -1.20 0.232
Belief (Fake) x FFNI Authoritativeness -1.49 0.51 (-2.50, -0.48) -2.89 0.004
Belief (Real) x FFNI Authoritativeness -1.57 0.51 (-2.58, -0.57) -3.08 0.002
Belief (Fake) x FFNI Distrust -0.17 0.46 (-1.08, 0.74) -0.36 0.718
Belief (Real) x FFNI Distrust 0.26 0.46 (-0.65, 1.17) 0.56 0.578
Belief (Fake) x FFNI Entitlement 0.11 0.55 (-0.97, 1.19) 0.20 0.843
Belief (Real) x FFNI Entitlement 0.52 0.55 (-0.56, 1.59) 0.94 0.346
Belief (Fake) x FFNI Exhibitionism 0.15 0.47 (-0.78, 1.08) 0.31 0.754
Belief (Real) x FFNI Exhibitionism 0.04 0.47 (-0.88, 0.97) 0.09 0.924
Belief (Fake) x FFNI Exploitativeness -0.48 0.46 (-1.38, 0.42) -1.04 0.298
Belief (Real) x FFNI Exploitativeness -0.22 0.46 (-1.12, 0.68) -0.48 0.631
Belief (Fake) x FFNI GrandioseFantasies 0.71 0.38 (-0.04, 1.46) 1.86 0.064
Belief (Real) x FFNI GrandioseFantasies 0.59 0.38 (-0.16, 1.33) 1.54 0.123
Belief (Fake) x FFNI Indifference 0.04 0.48 (-0.91, 0.98) 0.08 0.939
Belief (Real) x FFNI Indifference -0.32 0.48 (-1.26, 0.63) -0.66 0.512
Belief (Fake) x FFNI LackOfEmpathy 0.10 0.52 (-0.92, 1.12) 0.19 0.849
Belief (Real) x FFNI LackOfEmpathy 0.06 0.52 (-0.96, 1.07) 0.11 0.910
Belief (Fake) x FFNI Manipulativeness 0.50 0.52 (-0.52, 1.51) 0.96 0.336
Belief (Real) x FFNI Manipulativeness 0.32 0.51 (-0.68, 1.33) 0.63 0.528
Belief (Fake) x FFNI NeedForAdmiration -0.35 0.51 (-1.36, 0.66) -0.68 0.496
Belief (Real) x FFNI NeedForAdmiration -0.35 0.51 (-1.35, 0.65) -0.69 0.491
Belief (Fake) x FFNI ReactiveAnger 0.50 0.44 (-0.37, 1.36) 1.12 0.262
Belief (Real) x FFNI ReactiveAnger 0.50 0.44 (-0.36, 1.36) 1.14 0.256
Belief (Fake) x FFNI Shame -0.37 0.55 (-1.46, 0.71) -0.68 0.499
Belief (Real) x FFNI Shame -0.45 0.55 (-1.53, 0.63) -0.82 0.414
Belief (Fake) x FFNI ThrillSeeking -0.56 0.36 (-1.27, 0.14) -1.57 0.117
Belief (Real) x FFNI ThrillSeeking -0.41 0.36 (-1.11, 0.29) -1.14 0.253

p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1


p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF5722") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2


p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_Manipulativeness", fill = "#FF9800") + labs(x = "Narcissism (Manipulativeness)")
p_ffni3

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |              Parameter2 |   rho |         95% CI |       pd |               Prior |    BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real |     FFNI_AcclaimSeeking |  0.21 | [ 0.07,  0.36] | 99.70%** | Beta (5.20 +- 5.20) | 8.71* |       21.44**
## Confidence_Fake | FFNI_GrandioseFantasies |  0.20 | [ 0.03,  0.33] | 99.28%** | Beta (5.20 +- 5.20) | 5.72* |         3.73*
## Confidence_Fake |     FFNI_AcclaimSeeking |  0.19 | [ 0.04,  0.34] | 99.08%** | Beta (5.20 +- 5.20) | 3.86* |         4.39*
## Confidence_Real | FFNI_GrandioseFantasies |  0.18 | [ 0.03,  0.32] |  98.92%* | Beta (5.20 +- 5.20) | 3.25* |         4.15*
## n_Real          |   FFNI_Manipulativeness | -0.17 | [-0.32, -0.01] |  97.85%* | Beta (5.20 +- 5.20) |  2.14 |         0.985
## Confidence_Fake |   FFNI_Manipulativeness |  0.16 | [ 0.02,  0.32] |  98.00%* | Beta (5.20 +- 5.20) |  1.90 |          1.27
## 
## Observations: 145
cor_test(dfsub, "FFNI_Authoritativeness", "IPIP6_HonestyHumility")
## Parameter1             |            Parameter2 |     r |         95% CI | t(143) |         p
## --------------------------------------------------------------------------------------------
## FFNI_Authoritativeness | IPIP6_HonestyHumility | -0.35 | [-0.48, -0.20] |  -4.46 | < .001***
## 
## Observations: 145
# cor_test(dfsub, "FFNI_ThrillSeeking", "IPIP6_HonestyHumility")

Social Anxiety

f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.27 0.18 (0.97, 1.67) 1.76 0.079
Social Anxiety 1.53 0.62 (0.69, 3.41) 1.04 0.299
Social Phobia 0.75 0.27 (0.37, 1.53) -0.79 0.428


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.90 0.21 (0.49, 1.31) 4.30 < .001
Belief (Real) -0.22 0.04 (-0.30, -0.14) -5.29 < .001
Belief (Fake) x Social Anxiety -1.12 0.69 (-2.47, 0.23) -1.63 0.104
Belief (Real) x Social Anxiety -0.74 0.69 (-2.09, 0.60) -1.08 0.279
Belief (Fake) x Social Phobia 0.93 0.61 (-0.27, 2.13) 1.52 0.127
Belief (Real) x Social Phobia 0.70 0.61 (-0.49, 1.90) 1.15 0.249

# p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
# p_social 
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)

Intolerance to Uncertainty

f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.56 0.35 (1.00, 2.44) 1.97 0.049
IUS ProspectiveAnxiety 0.95 0.39 (0.43, 2.12) -0.12 0.906
IUS InhibitoryAnxiety 0.77 0.24 (0.42, 1.41) -0.85 0.397


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.52 0.37 (-0.20, 1.23) 1.41 0.157
Belief (Real) -0.30 0.08 (-0.45, -0.15) -3.88 < .001
Belief (Fake) x IUS ProspectiveAnxiety 1.16 0.68 (-0.18, 2.49) 1.70 0.090
Belief (Real) x IUS ProspectiveAnxiety 1.43 0.68 (0.10, 2.76) 2.10 0.036
Belief (Fake) x IUS InhibitoryAnxiety -0.91 0.52 (-1.93, 0.11) -1.75 0.081
Belief (Real) x IUS InhibitoryAnxiety -1.00 0.52 (-2.01, 0.02) -1.93 0.054
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)

Paranoid Beliefs

f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.45 0.18 (1.14, 1.84) 3.00 0.003
GPTS Reference 0.51 0.18 (0.25, 1.04) -1.86 0.062
GPTS Persecution 1.87 0.61 (0.99, 3.54) 1.93 0.054


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 1.07 0.18 (0.71, 1.43) 5.85 < .001
Belief (Real) -0.21 0.04 (-0.29, -0.14) -5.63 < .001
Belief (Fake) x GPTS Reference -0.99 0.61 (-2.18, 0.20) -1.63 0.104
Belief (Real) x GPTS Reference -1.07 0.61 (-2.26, 0.12) -1.76 0.079
Belief (Fake) x GPTS Persecution 0.47 0.55 (-0.62, 1.55) 0.84 0.400
Belief (Real) x GPTS Persecution 0.75 0.55 (-0.33, 1.83) 1.37 0.171

p_gpts1 <- plot_interindividual(m_real, m_conf, var = "GPTS_Persecution", fill = "#673AB7") + labs(x = "Paranoid Thoughts (Persecution)")
p_gpts1

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)

AI

rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)


efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
## 
## Variable              |  MR1  |  MR2  |  MR3  | Complexity | Uniqueness
## -----------------------------------------------------------------------
## AI_8_Exciting         | 0.82  | 0.16  | 0.18  |    1.18    |    0.27   
## AI_4_DailyLife        | 0.77  | 0.15  | 0.16  |    1.17    |    0.36   
## AI_9_Applications     | 0.71  | 0.06  | 0.12  |    1.07    |    0.47   
## AI_7_RealisticVideos  | 0.09  | 0.79  | 0.11  |    1.07    |    0.35   
## AI_5_ImitatingReality | 0.28  | 0.64  | 0.03  |    1.37    |    0.51   
## AI_1_RealisticImages  | 0.19  | 0.54  | 0.09  |    1.31    |    0.67   
## AI_3_VideosReal       | -0.13 | 0.41  | -0.20 |    1.69    |    0.77   
## AI_2_Unethical        | 0.20  | 0.07  | 0.72  |    1.17    |    0.44   
## AI_6_Dangerous        | 0.15  | -0.12 | 0.61  |    1.20    |    0.59   
## AI_10_FaceErrors      | 0.02  | 0.04  | 0.24  |    1.07    |    0.94   
## 
## The 3 latent factors (varimax rotation) accounted for 46.36% of the total variance of the original data (MR1 = 19.68%, MR2 = 15.76%, MR3 = 10.92%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
  cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |> 
  cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.34 0.11 (1.15, 1.57) 3.68 < .001
AI Enthusiasm 0.98 0.06 (0.87, 1.10) -0.41 0.682
AI Realness 1.06 0.06 (0.94, 1.19) 0.93 0.351
AI Danger 1.11 0.07 (0.98, 1.27) 1.63 0.103


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.83 0.09 (0.66, 1.01) 9.54 < .001
Belief (Real) -0.16 0.02 (-0.20, -0.13) -8.90 < .001
Belief (Fake) x AI Enthusiasm 0.31 0.10 (0.12, 0.50) 3.23 0.001
Belief (Real) x AI Enthusiasm 0.21 0.10 (0.02, 0.40) 2.20 0.028
Belief (Fake) x AI Realness 0.10 0.10 (-0.10, 0.30) 1.01 0.313
Belief (Real) x AI Realness 0.14 0.10 (-0.06, 0.33) 1.36 0.174
Belief (Fake) x AI Danger -0.09 0.11 (-0.30, 0.13) -0.79 0.431
Belief (Real) x AI Danger 0.04 0.11 (-0.17, 0.25) 0.38 0.707


p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") + 
  labs(x = "Enthusiasm about AI technology")
p_ai 

r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |    Parameter2 |  rho |        95% CI |       pd |               Prior |      BF | BF (Spearman)
## -----------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.22 | [ 0.06, 0.36] | 99.70%** | Beta (5.20 +- 5.20) | 12.32** |       17.75**
## Confidence_Real | AI_Enthusiasm | 0.18 | [ 0.02, 0.33] |  98.52%* | Beta (5.20 +- 5.20) |    2.83 |          2.82
## Confidence_Fake |   AI_Realness | 0.15 | [ 0.00, 0.30] |  97.15%* | Beta (5.20 +- 5.20) |    1.44 |          2.21
## 
## Observations: 145

Figures

fig1a <- (rez_at$p +
  theme(axis.text.x = element_blank()) +
  labs(x = "Attractiveness") |
  rez_gl$p +
    labs(x = "Beauty") +
    theme(
      axis.text.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
) /
  (rez_tr$p +
    labs(x = "Trustworthiness") |
    rez_fa$p +
      labs(x = "Familiarity") +
      theme(
        axis.text.y = element_blank(),
        axis.title.y = element_blank()
      )
  ) +
  plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
  plot_layout(guides = "collect") &
  theme(legend.title = element_text(face = "bold"))

fig <- wrap_elements(fig1a) /
  wrap_elements(
    # ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) + 
    ((p_ffni1 / p_ipip) | (p_ffni3 / p_gpts1) | (p_ffni2 / p_ai)) +
  plot_layout(guides = "collect") +
  plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) &
  theme(legend.title = element_text(face = "bold")) 
  ) +
  plot_layout(heights = c(1.1, 0.9)) 

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
  param <- cor_test(dfsub, x, y, bayesian = TRUE)

  # Format stat output
  r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
  CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
  CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")

  stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")

  label <- data.frame(
    x = min(dfsub[[x]], na.rm = TRUE),
    y = max(dfsub[[y]], na.rm = TRUE),
    label = stat
  )

  # Plot
  dfsub |>
    ggplot(aes_string(x = x, y = y)) +
    geom_point2(
      size = 3,
      color = fillx,
      # color = DVs[x],
      alpha = 2 / 3
    ) +
    geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
    labs(y = ylab, x = xlab) +
    geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fillx, color = "white") +
    ggside::geom_ysidedensity(fill = fill, color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))
}

p1 <- plot_correlation(dfsub,
  x = "IPIP6_HonestyHumility",
  y = "Confidence_Real",
  ylab = "Confidence that the stimulus is real",
  xlab = "Honesty-Humility",
  fillx = "#00BCD4",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p2 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p3 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is real",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p4 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p5 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p6 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_GrandioseFantasies",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Grandiose Fantasies)",
  fillx = "#FFC107",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

fig <- wrap_elements(fig1a) /
  wrap_elements(
    ((p3 / p2) | (p1 / p6) | (p4 / p5)) + 
  plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)

References